(define initializers '())

(define (declare-initializer! init-code)
  (set! initializers (cons init-code initializers)))

(define (declare-global! var value)
  (declare-initializer! `(define! ,(symbol->string var)
			   ,value)))

(define-macro (initializers)
  (if (null? initializers)
      (error "Are you sure there shouldn't be any initializers?")
      (cons 'begin initializers)))

(define-syntax define-initialized-module
  (syntax-rules (lambda)
    ((define-initialized-module (project module) defs ...)
     (begin
       (set! initializers '())
       (define-module (project module)
	 defs ...
	 (define-class module object
	   (define (load) (public static void)
	     (initializers))))))))

(define-macro (define-parser name/args documentation
		class-name
		indent-style tuple-arg parser-arg . body)
  (let ((form-name (first name/args))
	(arglist (cdr name/args)))
    (declare-global! form-name
      `(new ,class-name))
    `(define-class (,class-name) (parser "IArglist" "IDocumentable")
       (define (indent-style p)
	 ,indent-style)
       (define (documentation p)
	 (substitute-newlines ,documentation))
       (define (arglist p)
	 (new-array object
		    ,(length arglist)
		    ,@arglist))
       (define (parse this
		      (ilist z)
		      (parser ,parser-arg))
	 (let ((,tuple-arg (cast ilist z)))
	   ,@body)))))

(define (append->symbol a b)
  (define (stringify x)
    (if (string? x)
	x
	(symbol->string x)))

  (string->symbol (string-append (stringify a)
				 (stringify b))))

(define-macro (define-primitive-w/methods name/arglist supertype docs
		. methods)
  (let ((name (car name/arglist))
	(arglist (cdr name/arglist))
	(doc-code (if docs
		      `((define (documentation p)
			  "Documentation"
			  ,docs))
		      '())))
    (let ((classname (append->symbol "primitive-procedure-"
				     name)))
      (declare-global! name
		       `(new ,classname
			     (intern ,(symbol->string name))))
      `(define-class (,classname procedure-name) (,supertype "IArglist" "IDocumentable")
	 ("[Serializable]")
	 (define (arglist p)
	   (new-array object
		      ,(length arglist)
		      ,@(map (lambda (s)
			       `(intern ,(symbol->string s)))
			     arglist)))
	 ,@doc-code
	 ,@methods))))

(define-macro (define-primitive-procedure what . doc-and-body)
  (let* ((includes-docs? (and (> (length doc-and-body) 1)
			      (string? (car doc-and-body))))
	 (doc (if includes-docs?
		  (car doc-and-body)
		  #f))
	 (body (if includes-docs?
		   (cdr doc-and-body)
		   doc-and-body)))
    (if (list? (cdr what))
	(let* ((pname (car what))
	       (arglist-prototypes (cdr what))
	       (arglist (map (lambda (arg-prototype)
			       (if (pair? arg-prototype)
				   (cadr arg-prototype)
				   arg-prototype))
			     arglist-prototypes))
	       (unchecked-arg-names (map (lambda (name)
					   (append->symbol name "_arg"))
					 arglist))
	       (call (append->symbol "call"
				     (number->string
				      (length arglist)))))
	  `(define-primitive-w/methods (,pname ,@arglist)
	     call-interface-procedure
	     ,doc
	     (define (,call this ,@unchecked-arg-names)
	       ,@(append-map (lambda (arg-prototype arg-name)
			       (if (pair? arg-prototype)
				   (let ((type (car arg-prototype))
					 (name (cadr arg-prototype)))
				     (if (eq? type 'object)
					 '()
					 `((check-arg-type ,(symbol->string name)
							   ,arg-name
							   ,type))))
				   '()))
			     arglist-prototypes
			     unchecked-arg-names)
	       (let ,(map (lambda (prototype unchecked)
			    (if (pair? prototype)
				(let ((type (car prototype))
				      (name (cadr prototype)))
				  `(,name (cast ,type ,unchecked)))
				`(,prototype ,unchecked)))
			  arglist-prototypes
			  unchecked-arg-names)
		 ,@body))))
	(let* ((pname (car what))
	       (argsvar (cdr what))
	       (bodystart (car body)))
	  (cond ((and (pair? bodystart)
		      (eq? (car bodystart)
			   'arglist))
		 (set! arglist (cdr (car body)))
		 (set! body (cdr body))
		 (when (and (> (length body) 1)
			    (string? (first body)))
		   (set! doc (car body))
		   (set! body (cdr body)))
		 `(define-primitive-w/methods (,pname ,@arglist)
		    apply-interface-procedure
		    ,doc
		    (define (apply this ((array object) ,argsvar))
		      ,@body)))
		(else
		 `(define-primitive-w/methods (,pname ,argsvar ...)
		    apply-interface-procedure
		    ,doc
		    (define (apply this ((array object) ,argsvar))
		      ,@body))))))))

(define (trace-macro x)
  (pretty-print x)
  x)

(define-macro (import what doc-string)
  (let* ((operator (car what))
	 (index -1)
	 (arglist-prototypes
	  (map (lambda (prot)
		 (set! index (+ index 1))
		 (if (pair? prot)
		     prot
		     (list prot
			   (append->symbol prot
					   (string-append "-arg-"
							  (number->string
							   index))))))
	       (cdr what))))
    `(define-primitive-procedure (,operator ,@arglist-prototypes)
       ,doc-string
       (,operator ,@(map cadr arglist-prototypes)))))

;(define-macro (import what doc-string)
;  (let ((proc (string->symbol (string-append "primitive-procedure-"
;					     (symbol->string (car what)))))
;	(index 0)
;	(args (cdr what))
;	(type (lambda (arg)
;		(if (pair? arg)
;		    (car arg)
;		    arg)))
;	(name (lambda (arg)
;		(if (pair? arg)
;		    (cadr arg)
;		    arg))))
;    (declare-global! (car what) `(new ,proc))
;    `(define-class (,proc) procedure
;       (define (arglist p)
;	 (new-array object
;		    ,(length args)
;		    ,@(map (lambda (x)
;			     `(intern ,(symbol->string (name x))))
;			   args)))
;       (define (documentation p) "Documentation"
;	 ,doc-string)
;       (define (apply this ((array object) args))
;	 (check-nargs args ,(length args))
;	 (,(car what) ,@(map (lambda (arg)
;			 (let ((result `(cast ,(type arg)
;					      (vector-ref args ,index))))
;			   (set! index (+ index 1))
;			   result))
;		       args))))))

;(define-imported-class (eval-stack "EvalStack") object
;  (define (push-eval-stack "Push" (object e) (object o)) (public) void)
;  (define (pop-eval-stack "Pop") (public) void)
;  (define (alloc-frame (integer size)) (public) integer)
;  (define (pop-frame (integer location)) (public) void))
;  )

;(define-imported-object the-eval-stack "TopLevel.evalStack" eval-stack)

(define-macro (now-evaluating estack exp env . body)
  `(begin ,@body))
;  `(begin
;;     (push-eval-stack the-eval-stack ,exp ,env)
;    (push-eval-stack ,exp ,env)
;     (let ((xxretval (begin ,@body)))
;;       (pop-eval-stack the-eval-stack)
;       (pop-eval-stack)
;       xxretval)))

(define-macro (now-evaluating! estack exp env . body)
  `(begin ,@body))
;  `(begin
;;     (push-eval-stack the-eval-stack ,exp ,env)
;     (push-eval-stack ,exp ,env)
;     ,@body
;;     (pop-eval-stack the-eval-stack)
;     (pop-eval-stack)
;     ))

(define-macro (now-calling estack exp env . body)
  `(begin
;     (push-eval-stack the-eval-stack ,exp ,env)
    (push ,estack ,exp ,env)
     (let ((xxretval (begin ,@body)))
;       (pop-eval-stack the-eval-stack)
       (pop ,estack)
       xxretval)))

(define-macro (now-calling! stack exp env . body)
  `(begin
;     (push-eval-stack the-eval-stack ,exp ,env)
     (push ,stack ,exp ,env)
     ,@body
;     (pop-eval-stack the-eval-stack)
     (pop ,stack)
     ))

(import-static (number? "Utilities.IsNumber" (proc (object) boolean))
	       (integer? "Utilities.IsInteger" (proc (object) boolean))
	       (to-double "Convert.ToDouble" (proc (object) float))
	       (to-single "Convert.ToSingle" (proc (object) single-float))
	       (to-int32 "Convert.ToInt32" (proc (object) integer)))

(%import-object 'number-type
		"PseudoType.Number"
		(type-expression-value 'clr-type))

(define-macro (check-arg-type arg-name arg type)
  (case type
    ((float)
     `(unless (number? ,arg)
	(throw (new argument-type-exception
		    ,arg-name
		    ,arg
		    (type->clr-type ,type)))))
    ((number)
     `(unless (number? ,arg)
	(throw (new argument-type-exception
		    ,arg-name
		    ,arg
		    number-type))))
    (else
     `(unless (is? ,arg ,type)
	(throw (new argument-type-exception
		    ,arg-name
		    ,arg
		    (type->clr-type ,type)))))))

(define-macro (checked-cast message type value)
  (let ((var (gensym "cast")))
    `(let ((,var ,value))
       (unless (is? ,var ,type)
	 (throw (new type-exception
		     ,message
		     ,var
		     (type->clr-type ,type))))
       (cast ,type ,var))))

(define-macro (checked-test-cast message value)
  (let ((var (gensym "cast")))
    `(let ((,var ,value))
       (unless (is? ,var boolean)
	 (throw (new test-type-exception
		     ,message
		     ,var)))
       (cast boolean ,var))))

(define-macro (checked-arg-cast arg-name value type)
  (let ((var (append->symbol "cast" value)))
    `(let ((,var (as ,value ,type)))
       (when (null? ,var)
	 (throw (new argument-type-exception
		     ,arg-name
		     ,value
		     (type->clr-type ,type))))
       ,var)))

(define-macro (define-inequality < docstring)
  `(define-primitive-w/methods (,< number number ...)
    call-interface-procedure
    ,docstring
    (define (call2 this n1 n2)
      (check-arg-type "number" n1 number)
      (check-arg-type "number" n2 number)
      (if (and (integer? n1)
	       (integer? n2))
	  (,< (to-int32 n1)
	     (to-int32 n2))
	  (,< (to-double n1)
	     (to-double n2))))
    (define (call3 this n1 n2 n3)
      (check-arg-type "number" n1 number)
      (check-arg-type "number" n2 number)
      (check-arg-type "number" n3 number)
      (if (and (integer? n1)
	       (integer? n2)
	       (integer? n3))
	  (let ((in2 (to-int32 n2)))
	    (and (,< (to-int32 n1)
		    in2)
		 (,< in2
		    (to-int32 n3))))
	  (let ((dn2 (to-double n2)))
	    (and (,< (to-double n1)
		    dn2)
		 (,< dn2 (to-double n3))))))
    (define (call4 this n1 n2 n3 n4)
      (check-arg-type "number" n1 number)
      (check-arg-type "number" n2 number)
      (check-arg-type "number" n3 number)
      (check-arg-type "number" n4 number)
      (if (and (integer? n1)
	       (integer? n2)
	       (integer? n3)
	       (integer? n4))
	  (let ((in2 (to-int32 n2))
		(in3 (to-int32 n3)))
	    (and (,< (to-int32 n1)
		    in2)
		 (,< in2 in3)
		 (,< in3
		    (to-int32 n4))))
	  (let ((dn2 (to-double n2))
		(dn3 (to-double n3)))
	    (and (,< (to-double n1)
		    dn2)
		 (,< dn2 dn3)
		 (,< dn3 (to-double n4))))))
    (define (call4 this n1 n2 n3 n4 n5)
      (check-arg-type "number" n1 number)
      (check-arg-type "number" n2 number)
      (check-arg-type "number" n3 number)
      (check-arg-type "number" n4 number)
      (check-arg-type "number" n5 number)
      (if (and (integer? n1)
	       (integer? n2)
	       (integer? n3)
	       (integer? n4)
	       (integer? n5))
	  (let ((in2 (to-int32 n2))
		(in3 (to-int32 n3))
		(in4 (to-int32 n4)))
	    (and (,< (to-int32 n1)
		    in2)
		 (,< in2 in3)
		 (,< in3 in4)
		 (,< in4
		    (to-int32 n5))))
	  (let ((dn2 (to-double n2))
		(dn3 (to-double n3))
		(dn4 (to-double n4)))
	    (and (,< (to-double n1)
		    dn2)
		 (,< dn2 dn3)
		 (,< dn3 dn4)
		 (,< dn4 (to-double n5))))))))